home *** CD-ROM | disk | FTP | other *** search
/ Especial Multimedia / Especial Multimedia.iso / Multimed / Prg / PROGRESS.ZIP / ON_TOP.ZIP / ON_TOP.BAS < prev    next >
BASIC Source File  |  1994-12-29  |  6KB  |  183 lines
  1. Option Explicit
  2.   '
  3.   ' CONSTANTS
  4.   '
  5.     '
  6.     ' Global Constants for Stay On Top call
  7.     '
  8.       Global Const SWP_NOMOVE = 2
  9.       Global Const SWP_NOSIZE = 1
  10.       Global Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
  11.       Global Const HWND_TOPMOST = -1
  12.       Global Const HWND_NOTOPMOST = -2
  13.     '
  14.     ' System Menu Constants
  15.     '
  16.       Global Const MF_SEPARATOR = &H800
  17.       Global Const MF_STRING = &H0
  18.       Global Const MF_ENABLED = 0
  19.       Global Const MF_BYCOMMAND = &H0
  20.       Global Const MF_UNCHECKED = &H0
  21.       Global Const MF_CHECKED = &H8
  22.       Global Const MF_BYPOSITION = &H400
  23.   
  24.       Global Const SM_TOOLBOX = 1
  25.       Global Const SM_PROP = 2
  26.       Global Const SM_PROJECT = 3
  27.       Global Const SM_BOXES = 4
  28.       Global Const SM_ABOUT = 5
  29.       
  30.       Global Const SMT_TOOLBOX = "&Toolbox On Top"
  31.       Global Const SMT_PROJECT = "&Project Box On Top"
  32.       Global Const SMT_PROP = "P&roperties Box On Top"
  33.       Global Const SMT_BOXES = "'&Boxes On Top' On Top"
  34.       Global Const SMT_ABOUT = "&About 'Boxes On Top'..."
  35.     '
  36.     ' Windows Message Constants
  37.     '
  38.       Global Const WM_QUERYOPEN = &H13    'restore minimized window message
  39.       Global Const WM_SYSCOMMAND = &H112  'system command message
  40.   '
  41.   ' API CALLS
  42.   '
  43.     '
  44.     ' FindWindow API call to locate VB Tools
  45.     '
  46.       Declare Function FindWindow Lib "User" (ByVal lpClassName As Any, ByVal lpCaption As Any) As Integer
  47.     '
  48.     ' SetWindowPos API call used to toggle window stay on top status
  49.     '
  50.       Declare Function SetWindowPos Lib "User" (ByVal h As Integer, ByVal hb As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal f As Integer) As Integer
  51.     '
  52.     ' System Menu API Declarations
  53.     '
  54.       '
  55.       ' Append or Remove menu items
  56.       '
  57.         Declare Function AppendMenu Lib "USER" (ByVal hMenu As Integer, ByVal wFlags As Integer, ByVal wIDNewItem As Integer, ByVal lpNewItem As Any) As Integer
  58.         Declare Function RemoveMenu Lib "USER" (ByVal hMenu As Integer, ByVal nPosition As Integer, ByVal wFlags As Integer) As Integer
  59.       '
  60.       ' Get System Menu handle
  61.       '
  62.         Declare Function GetSystemMenu Lib "USER" (ByVal hWnd As Integer, ByVal bRevert As Integer) As Integer
  63.       '
  64.       ' Get the state of and modify System Menu items. Used to check and
  65.       ' uncheck menu items
  66.       '
  67.         Declare Function GetMenuState Lib "USER" (ByVal hMenu As Integer, ByVal wId As Integer, ByVal wFlags As Integer) As Integer
  68.         Declare Function ModifyMenuBystring Lib "USER" Alias "ModifyMenu" (ByVal hMenu As Integer, ByVal nPosition As Integer, ByVal wFlags As Integer, ByVal wIDNewItem As Integer, ByVal lpString As String) As Integer
  69.  
  70. Sub CheckOnTop (iMenuItem As Integer, sMenuTitle As String, iStatus As Integer)
  71.   '
  72.   ' Place checkmark on or remove checkmark from specified menu item.
  73.   '
  74.   Dim iResult As Integer
  75.   Dim hMenu As Integer
  76.   hMenu = GetSystemMenu(frmMain.hWnd, False)
  77.   If iStatus = MF_UNCHECKED Then
  78.     iResult = ModifyMenuBystring(hMenu, iMenuItem + 5, MF_UNCHECKED Or MF_BYPOSITION, iMenuItem, sMenuTitle)
  79.   Else
  80.     iResult = ModifyMenuBystring(hMenu, iMenuItem + 5, MF_CHECKED Or MF_BYPOSITION, iMenuItem, sMenuTitle)
  81.   End If
  82. End Sub
  83.  
  84. Function GetHwnd (sWindowClass As String, sWindowName As String) As Integer
  85.   '
  86.   ' Retrieves a Window's hWnd value.
  87.   ' Requires either Class name or Windows Titlebar Caption
  88.   '
  89.   If sWindowClass = "" And sWindowName <> "" Then
  90.     GetHwnd = FindWindow(0&, sWindowName)
  91.   ElseIf sWindowClass <> "" And sWindowName = "" Then
  92.     GetHwnd = FindWindow(sWindowClass, 0&)
  93.   ElseIf sWindowClass <> "" And sWindowName <> "" Then
  94.     GetHwnd = FindWindow(sWindowClass, sWindowName)
  95.   Else
  96.     GetHwnd = 0
  97.   End If
  98. End Function
  99.  
  100. Function IsMenuChecked (iMenuItem As Integer) As Integer
  101.   '
  102.   '  See if System Menu Item is checked or not
  103.   '
  104.   Dim iResult As Integer
  105.   Dim hMenu As Integer
  106.   hMenu = GetSystemMenu(frmMain.hWnd, False)
  107.   iResult = GetMenuState(hMenu, iMenuItem, MF_BYCOMMAND)
  108.   If iResult = MF_CHECKED Then
  109.     IsMenuChecked = True
  110.   Else
  111.     IsMenuChecked = False
  112.   End If
  113. End Function
  114.  
  115. Sub SetupDialogMenu (frm As Form)
  116.   Dim hMenu As Integer
  117.   Dim iResult As Integer
  118.   hMenu = GetSystemMenu(frm.hWnd, 0)
  119.   '
  120.   ' Remove all but the MOVE and CLOSE options. Note that
  121.   ' the min and max buttons are assumed to be set to
  122.   ' false and the form's BorderStyle is assumed to be
  123.   ' fixed double.
  124.   '
  125.   iResult = RemoveMenu(hMenu, 8, MF_BYPOSITION) 'Switch to
  126.   iResult = RemoveMenu(hMenu, 7, MF_BYPOSITION) 'Separator
  127.   iResult = RemoveMenu(hMenu, 5, MF_BYPOSITION) 'Separator
  128. End Sub
  129.  
  130. Sub SysMenuBuild ()
  131.   '
  132.   ' Add Additional Menu Strings to System Menu
  133.   '
  134.   Dim hMenu As Integer
  135.   Dim iResult As Integer
  136.   hMenu = GetSystemMenu(frmMain.hWnd, False)
  137.   iResult = AppendMenu(hMenu, MF_SEPARATOR, 0, "")
  138.   iResult = AppendMenu(hMenu, MF_STRING, SM_TOOLBOX, SMT_TOOLBOX)
  139.   iResult = AppendMenu(hMenu, MF_STRING, SM_PROP, SMT_PROP)
  140.   iResult = AppendMenu(hMenu, MF_STRING, SM_PROJECT, SMT_PROJECT)
  141.   iResult = AppendMenu(hMenu, MF_STRING, SM_BOXES, SMT_BOXES)
  142.   iResult = AppendMenu(hMenu, MF_SEPARATOR, 0, "")
  143.   iResult = AppendMenu(hMenu, MF_STRING, SM_ABOUT, SMT_ABOUT)
  144. End Sub
  145.  
  146. Sub ToggleWindowStatus (wParam As Integer, sWinClass As String, sWinTitle As String, sMenuText As String)
  147.   If IsMenuChecked(wParam) Then
  148.     If WindowOnTop(sWinClass, sWinTitle, False) Then
  149.       CheckOnTop wParam, sMenuText, MF_UNCHECKED
  150.     End If
  151.   Else
  152.     If WindowOnTop(sWinClass, sWinTitle, True) Then
  153.       CheckOnTop wParam, sMenuText, MF_CHECKED
  154.     End If
  155.   End If
  156. End Sub
  157.  
  158. Function WindowOnTop (sWinClass As String, sWinTitle As String, iToggle As Integer) As Integer
  159.   '
  160.   ' Reports True if operation is successful, False if not.
  161.   '
  162.   Dim iResult As Integer
  163.   Dim hWnd As Integer
  164.   '
  165.   ' Get Window handle
  166.   '
  167.   hWnd = GetHwnd(sWinClass, sWinTitle)
  168.   '
  169.   ' If Window is present, then toggle it
  170.   '
  171.   If hWnd <> 0 Then
  172.     If iToggle Then
  173.       iResult = SetWindowPos(hWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS)
  174.     Else
  175.       iResult = SetWindowPos(hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS)
  176.     End If
  177.     WindowOnTop = True
  178.   Else
  179.     WindowOnTop = False
  180.   End If
  181. End Function
  182.  
  183.